!!M Inlines.f
!!G AEvent.finc
c
c
	program AEMenu

	implicit none
	
	external get_reply,send_array
	integer*2 err
	
	err = AEInstallEventHandler (%val('aevt'),%val('ansr'),%val(%loc(get_reply)),%val(int4(0)),%val(int2(0))) 
	if (err. ne. 0) then
		type *,'Error installing Apple event, result code = ',err
	end if

	call AddMenuItem ('AE menu','setup array',setup_array)
	call AddMenuItem ('AE menu','send array',send_array)
	call AddMenuItem ('AE menu','show array',show_array)
	
	end
	
	subroutine setup_array
	implicit none
	
	real*4 myarray(10000)
	integer xdim,ydim
	global xdim,ydim,myarray
	
	xdim = 10
	ydim = 15
	call setarray(myarray,xdim,ydim)
	
	return
	end

	subroutine setarray(array,xdim,ydim)
	integer xdim,ydim
	real*4 array(xdim,ydim)
	
	do i=1,xdim
		do j=1,ydim
		array(i,j) = 10000.*(i-1) + 1.*(j-1)
		end do
	end do
	
	return
	end

	subroutine show_array
	implicit none
	
	real*4 myarray(10000)
	integer xdim,ydim
	global xdim,ydim,myarray
	
	xdim = 10
	ydim = 15
	call display(myarray,xdim,ydim)
	
	return
	end

	subroutine display(array,xdim,ydim)
	integer xdim,ydim
	real*4 array(xdim,ydim)
	
	write (*,'(1x,10(1xf7.0))') ((array(i,j),i=1,xdim),j=1,ydim)
	
	return
	end

	subroutine send_array
	implicit none
	
	real*4 myarray(10000)

	integer xdim,ydim
	global xdim,ydim,myarray
	
	integer totalsize
	
	integer*2 err
	record /AppleEvent/ theAppleEvent,reply
	record /targetID/ target
	record /LocationNameRec/ myLocation
	record /PortInfoRec/ myPortInfo
	record /AEAddressDesc/ targetAddress
	
	err = PPCBrowser(%val(int4(0)),%val(int4(0)),%val(int2(0)),
	1	%ref(myLocation),%ref(myPortInfo),%val(int4(0)),%val(int4(0)))
	if (err	.ne. 0) then
		type *,'PPC Browser: error ',err
		return
	end if
	
	target.location = myLocation
	target.name = myPortInfo.name
	
	type *,'Session ID = ',target.sessionid,', target name = ',target.name.name
	
	err = AECreateDesc(%val(typeTargetID),%val(%loc(target)),
	1				%val(sizeof(target)),%ref(targetAddress))
	if (err	.ne. 0) then
		type *,'AECreateDesc: error ',err
		return
	end if	
	
	err = AECreateAppleEvent(%val('JLMT'),%val('MULT'),%ref(targetAddress),
	1		%val(kAutoGenerateReturnID),%val(int4(kAnyTransactionID)),
	2		%ref(theAppleEvent))
	if (err	.ne. 0) then
		type *,'AECreateAppleEvent: error ',err
		return
	end if	
	
	err = AEPutParamPtr(%ref(theAppleEvent),%val('XDIM'),%val(typeInteger),
	1		%val(%loc(xdim)),%val(sizeof(xdim)))
	if (err	.ne. 0) then
		type *,'AEPutParamPtr: error ',err
		return
	end if	
	
	err = AEPutParamPtr(%ref(theAppleEvent),%val('YDIM'),%val(typeInteger),
	1		%val(%loc(ydim)),%val(sizeof(ydim)))
	if (err	.ne. 0) then
		type *,'AEPutParamPtr: error ',err
		return
	end if	
	
	totalsize = xdim * ydim * 4
	
	err = AEPutParamPtr(%ref(theAppleEvent),%val('ARRY'),%val(typeChar),
	1		%val(%loc(myarray)),%val(totalsize))
	if (err	.ne. 0) then
		type *,'AEPutParamPtr: error ',err
		return
	end if	
	
	err = AESend(%ref(theAppleEvent),%ref(reply),
	1		%val(int4(kAEQueueReply+kAENeverInteract)),
	2		%val(kAENormalPriority), %val(int4(120)), %val(int4(0)),%val(int4(0)) )
	if (err	.ne. 0) then
		type *,'AESend: error ',err
		return
	end if	
	
	type *,'Sent test array of size ',xdim*ydim

	return
	end

	integer*2 function get_reply(theAppleEvent,reply,%val(handlerRefCon))
	record /AppleEvent/ theAppleEvent
	record /AppleEvent/ reply
	integer*4 handlerRefCon
	
	real*4 myarray(10000)
	integer xdim,ydim
	global xdim,ydim,myarray
	
	integer totalsize
	
	err = AEGetParamPtr(%ref(theAppleEvent),%val('XDIM'),%val(typeInteger),
	1		returnedType,%val(%loc(xdim)),%val(sizeof(xdim)),actualSize)
	if (err	.ne. 0) then
		type *,'AEGetParamPtr: error ',err
		goto 9999
	end if	
	
	err = AEGetParamPtr(%ref(theAppleEvent),%val('YDIM'),%val(typeInteger),
	1		returnedType,%val(%loc(ydim)),%val(sizeof(ydim)),actualSize)
	if (err	.ne. 0) then
		type *,'AEGetParamPtr: error ',err
		goto 9999
	end if	
	
	totalsize = xdim * ydim * 4
	
	err = AEGetParamPtr(%ref(theAppleEvent),%val('ARRY'),%val(typeChar),
	1		returnedType,%val(%loc(myarray)),%val(totalsize),actualSize)
	if (err	.ne. 0) then
		type *,'AEGetParamPtr: error ',err
		goto 9999
	end if	
	
	type *,'Reply received from server'
	
	get_reply = 0	! noErr
	return

9999	get_reply = err	
		return
	end
